home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_gnu / adainc / s-taspri.adb < prev    next >
Text File  |  1996-01-30  |  26KB  |  791 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                 GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS               --
  4. --                                                                          --
  5. --                S Y S T E M . T A S K _ P R I M I T I V E S               --
  6. --                                                                          --
  7. --                                  B o d y                                 --
  8. --                                                                          --
  9. --                             $Revision: 1.22 $                             --
  10. --                                                                          --
  11. --       Copyright (c) 1991,1992,1993,1994, FSU, All Rights Reserved        --
  12. --                                                                          --
  13. -- GNARL is free software; you can redistribute it  and/or modify it  under --
  14. -- terms  of  the  GNU  Library General Public License  as published by the --
  15. -- Free Software  Foundation;  either version 2, or (at  your  option)  any --
  16. -- later  version.  GNARL is distributed  in the hope that  it will be use- --
  17. -- ful, but but WITHOUT ANY WARRANTY;  without even the implied warranty of --
  18. -- MERCHANTABILITY  or  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Gen- --
  19. -- eral Library Public License  for more details.  You should have received --
  20. -- a  copy of the GNU Library General Public License along with GNARL;  see --
  21. -- file COPYING.LIB.  If not,  write to the  Free Software Foundation,  675 --
  22. -- Mass Ave, Cambridge, MA 02139, USA.                                      --
  23. --                                                                          --
  24. ------------------------------------------------------------------------------
  25.  
  26. with System.Task_Clock;
  27. --  Used for, Stimespec,
  28. --            Stimespec_Seconds,
  29. --            Stimespec_NSeconds
  30.  
  31. with Interfaces.C.POSIX_timers;
  32. --  Used for, timespec,
  33. --            Nanoseconds
  34.  
  35. with Interfaces.C.POSIX_Error;
  36. --  Used for, Return_Code,
  37. --            Failure,
  38. --            Get_Error_Code,
  39. --            Interrupted_Operation,
  40. --            Resource_Temporarily_Unavailable,
  41. --            Priority_Ceiling_Violation
  42.  
  43. with Interfaces.C.POSIX_RTE;
  44. --  Used for, Signal,
  45. --            Signal_Set,
  46. --            Signal_Add,
  47. --            Signal_Add_All,
  48. --            Signal_Delete,
  49. --            Signal_Delete_All,
  50. --            sigprocmask,
  51. --            siginfo_ptr,
  52. --            struct_sigaction,
  53. --            sigaction,
  54. --            Is_Member,
  55. --            and various CONSTANTS
  56.  
  57. with Interfaces.C.Pthreads; use Interfaces.C.Pthreads;
  58.  
  59. with Unchecked_Deallocation;
  60.  
  61. with Unchecked_Conversion;
  62.  
  63. package body System.Task_Primitives is
  64.  
  65.    package RTE renames POSIX_RTE;
  66.  
  67.    Failure : Interfaces.C.POSIX_Error.Return_Code
  68.       renames Interfaces.C.POSIX_Error.Failure;
  69.  
  70.    Test_And_Set_Mutex : Lock;
  71.    --  Use a mutex to simulate test-and-set.  This is ridiculously inefficient;
  72.    --  it is just here so that I can fix the syntax errors without having to
  73.    --  worry about how to get machine code into the system in the absense
  74.    --  of machine code inserts.
  75.  
  76.    Abort_Signal : constant RTE.Signal := RTE.SIGUSR1;
  77.  
  78.    function "=" (L, R : System.Address) return Boolean
  79.      renames System."=";
  80.  
  81.    ATCB_Key : pthread_key_t;
  82.  
  83.    Abort_Handler : Abort_Handler_Pointer;
  84.  
  85.    LL_Signals       : RTE.Signal_Set;
  86.    Task_Signal_Mask : RTE.Signal_Set;
  87.  
  88.    Reserved_Signals : RTE.Signal_Set;
  89.  
  90.    Assertions_Checked : constant Boolean := True;
  91.  
  92.    procedure Put_Character (C : Integer);
  93.    pragma Import (C, Put_Character, "putchar");
  94.  
  95.    procedure Prog_Exit (Status : Integer);
  96.    pragma Import (C, Prog_Exit, "exit");
  97.  
  98.    function Pointer_to_Address is new
  99.      Unchecked_Conversion (TCB_Ptr, System.Address);
  100.  
  101.    function Address_to_Pointer is new
  102.      Unchecked_Conversion (System.Address, TCB_Ptr);
  103.  
  104.    -----------------------
  105.    -- Local Subprograms --
  106.    -----------------------
  107.  
  108.    procedure Abort_Wrapper
  109.      (signo   : Integer;
  110.       info    : RTE.siginfo_ptr;
  111.       context : System.Address);
  112.    --  This is a signal handler procedure which calls the user-specified
  113.    --  abort handler procedure.
  114.  
  115.    procedure Assert (B : Boolean; M : String);
  116.    pragma Inline (Assert);
  117.    --  Output string M if B is True and Assertions_Checked
  118.  
  119.    function Get_Stack_Limit return System.Address;
  120.    pragma Inline (Get_Stack_Limit);
  121.    --  Obtains stack limit from TCB
  122.  
  123.    procedure LL_Wrapper (T : TCB_Ptr);
  124.    --  A wrapper procedure that is called from a new low-level task.
  125.    --  It performs initializations for the new task and calls the
  126.    --  user-specified startup procedure.
  127.  
  128.    procedure Write_Character (C : Character);
  129.    procedure Write_EOL;
  130.    procedure Write_String (S : String);
  131.    --  Debugging procedures used for assertion output
  132.  
  133.    ---------------------
  134.    -- Write_Character --
  135.    ---------------------
  136.  
  137.    procedure Write_Character (C : Character) is
  138.    begin
  139.       Put_Character (Character'Pos (C));
  140.    end Write_Character;
  141.  
  142.    ---------------
  143.    -- Write_Eol --
  144.    ---------------
  145.  
  146.    procedure Write_EOL is
  147.    begin
  148.       Write_Character (Ascii.LF);
  149.    end Write_EOL;
  150.  
  151.    ------------------
  152.    -- Write_String --
  153.    ------------------
  154.  
  155.    procedure Write_String (S : String) is
  156.    begin
  157.       for J in S'Range loop
  158.          Write_Character (S (J));
  159.       end loop;
  160.    end Write_String;
  161.  
  162.    ---------------
  163.    -- LL_Assert --
  164.    ---------------
  165.  
  166.    procedure LL_Assert (B : Boolean; M : String) is
  167.    begin
  168.       if not B then
  169.          Write_String ("Failed assertion: ");
  170.          Write_String (M);
  171.          Write_String (".");
  172.          Write_EOL;
  173.          Prog_Exit (1);
  174.       end if;
  175.    end LL_Assert;
  176.  
  177.    ------------
  178.    -- Assert --
  179.    ------------
  180.  
  181.    procedure Assert (B : Boolean; M : String) is
  182.    begin
  183.       if Assertions_Checked then
  184.          LL_Assert (B, M);
  185.       end if;
  186.    end Assert;
  187.  
  188.    -------------------------
  189.    -- Initialize_LL_Tasks --
  190.    -------------------------
  191.  
  192.    procedure Initialize_LL_Tasks (T : TCB_Ptr) is
  193.       Old_Set : RTE.Signal_Set;
  194.       Mask    : RTE.Signal_Set;
  195.       Result  : Interfaces.C.POSIX_Error.Return_Code;
  196.  
  197.    begin
  198.    --  WARNING : SIGALRM should not be in the following mask.  SIGALRM should
  199.    --          be a normal user signal under 1, and should be enabled
  200.    --          by the client.  However, the current RTS built on 1
  201.    --          uses nanosleep () and pthread_cond_wait (), which fail if all
  202.    --          threads have SIGALRM masked. ???
  203.  
  204.       RTE.Signal_Delete_All (LL_Signals);
  205.       RTE.Signal_Add (LL_Signals, Abort_Signal);
  206.       RTE.Signal_Add (LL_Signals, RTE.SIGALRM);
  207.       RTE.Signal_Add (LL_Signals, RTE.SIGILL);
  208.       RTE.Signal_Add (LL_Signals, RTE.SIGABRT);
  209.       RTE.Signal_Add (LL_Signals, RTE.SIGFPE);
  210.       RTE.Signal_Add (LL_Signals, RTE.SIGSEGV);
  211.  
  212.       --  SunOS related Sysnchronous signals.
  213.       RTE.Signal_Delete (LL_Signals, RTE.SIGTRAP);
  214.       RTE.Signal_Delete (LL_Signals, RTE.SIGEMT);
  215.       RTE.Signal_Delete (LL_Signals, RTE.SIGBUS);
  216.  
  217.       RTE.Signal_Add_All (Task_Signal_Mask);
  218.       RTE.Signal_Delete (Task_Signal_Mask, Abort_Signal);
  219.       RTE.Signal_Delete (Task_Signal_Mask, RTE.SIGALRM);
  220.       RTE.Signal_Delete (Task_Signal_Mask, RTE.SIGILL);
  221.       RTE.Signal_Delete (Task_Signal_Mask, RTE.SIGABRT);
  222.       RTE.Signal_Delete (Task_Signal_Mask, RTE.SIGFPE);
  223.       RTE.Signal_Delete (Task_Signal_Mask, RTE.SIGSEGV);
  224.  
  225.       --  SunOS related Sysnchronous signals.
  226.       RTE.Signal_Delete (Task_Signal_Mask, RTE.SIGTRAP);
  227.       RTE.Signal_Delete (Task_Signal_Mask, RTE.SIGEMT);
  228.       RTE.Signal_Delete (Task_Signal_Mask, RTE.SIGBUS);
  229.  
  230.       RTE.Signal_Delete_All (Reserved_Signals);
  231.       RTE.Signal_Add (Reserved_Signals, RTE.SIGILL);
  232.       RTE.Signal_Add (Reserved_Signals, RTE.SIGABRT);
  233.       RTE.Signal_Add (Reserved_Signals, RTE.SIGFPE);
  234.       RTE.Signal_Add (Reserved_Signals, RTE.SIGSEGV);
  235.       RTE.Signal_Add (Reserved_Signals, Abort_Signal);
  236.  
  237.       --  SunOS related Sysnchronous signals.
  238.       RTE.Signal_Delete (Reserved_Signals, RTE.SIGTRAP);
  239.       RTE.Signal_Delete (Reserved_Signals, RTE.SIGEMT);
  240.       RTE.Signal_Delete (Reserved_Signals, RTE.SIGBUS);
  241.  
  242.       pthread_key_create (ATCB_Key, System.Null_Address, Result);
  243.  
  244.       if Result = Failure then
  245.          raise Storage_Error;               --  Insufficiant resources.
  246.       end if;
  247.  
  248.       RTE.sigprocmask (RTE.SIG_SETMASK, Task_Signal_Mask, Old_Set, Result);
  249.       Assert (Result /= Failure, "GNULLI failure---sigprocmask");
  250.  
  251.       T.LL_Entry_Point := null;
  252.  
  253.       T.Thread := pthread_self;
  254.       pthread_setspecific (ATCB_Key, Pointer_to_Address (T), Result);
  255.       Assert (Result /= Failure, "GNULLI failure---pthread_setspecific");
  256.  
  257.    end Initialize_LL_Tasks;
  258.  
  259.    ----------
  260.    -- Self --
  261.    ----------
  262.  
  263.    function Self return TCB_Ptr is
  264.       Temp   : System.Address;
  265.       Result : Interfaces.C.POSIX_Error.Return_Code;
  266.  
  267.    begin
  268.       pthread_getspecific (ATCB_Key, Temp, Result);
  269.       Assert (Result /= Failure, "GNULLI failure---pthread_getspecific");
  270.       return Address_to_Pointer (Temp);
  271.    end Self;
  272.  
  273.    ---------------------
  274.    -- Initialize_Lock --
  275.    ---------------------
  276.  
  277.    procedure Initialize_Lock
  278.      (Prio : System.Priority;
  279.       L    : in out Lock)
  280.    is
  281.       Attributes : pthread_mutexattr_t;
  282.       Result     : Interfaces.C.POSIX_Error.Return_Code;
  283.  
  284.    begin
  285.       pthread_mutexattr_init (Attributes, Result);
  286.       if Result = Failure then
  287.          raise STORAGE_ERROR;  --  should be ENOMEM
  288.       end if;
  289.  
  290.       pthread_mutexattr_setprotocol (Attributes, PRIO_PROTECT, Result);
  291.  
  292.       Assert (Result /= Failure,
  293.         "GNULLI failure---pthread_mutexattr_setprotocol");
  294.  
  295.       pthread_mutexattr_setprio_ceiling
  296.          (Attributes, Interfaces.C.int (Prio), Result);
  297.  
  298.       Assert (Result /= Failure,
  299.         "GNULLI failure---pthread_mutexattr_setprio_ceiling");
  300.  
  301.       pthread_mutex_init (pthread_mutex_t (L), Attributes, Result);
  302.  
  303.       if Result = Failure then
  304.          raise STORAGE_ERROR;  --  should be ENOMEM ???
  305.       end if;
  306.    end Initialize_Lock;
  307.  
  308.    -------------------
  309.    -- Finalize_Lock --
  310.    -------------------
  311.  
  312.    procedure Finalize_Lock (L : in out Lock) is
  313.       Result : Interfaces.C.POSIX_Error.Return_Code;
  314.  
  315.    begin
  316.       pthread_mutex_destroy (pthread_mutex_t (L), Result);
  317.       Assert (Result /= Failure, "GNULLI failure---pthread_mutex_destroy");
  318.    end Finalize_Lock;
  319.  
  320.    ----------------
  321.    -- Write_Lock --
  322.    ----------------
  323.  
  324.    --  The error code EINVAL indicates either an uninitialized mutex or
  325.    --  a priority ceiling violation. We assume that the former cannot
  326.    --  occur in our system.
  327.    procedure Write_Lock (L : in out Lock; Ceiling_Violation : out Boolean) is
  328.       Result : Interfaces.C.POSIX_Error.Return_Code;
  329.       Ceiling_Error : Boolean;
  330.    begin
  331.       pthread_mutex_lock (pthread_mutex_t (L), Result);
  332.       Ceiling_Error := Result = Failure and then
  333.         Interfaces.C.POSIX_Error.Get_Error_Code =
  334.            Interfaces.C.POSIX_Error.Priority_Ceiling_Violation;
  335.       Assert (Result /= Failure or else Ceiling_Error,
  336.         "GNULLI failure---pthread_mutex_lock");
  337.       Ceiling_Violation := Ceiling_Error;
  338.    end Write_Lock;
  339.  
  340.    ---------------
  341.    -- Read_Lock --
  342.    ---------------
  343.  
  344.    procedure Read_Lock (L : in out Lock; Ceiling_Violation : out Boolean) is
  345.    begin
  346.       Write_Lock (L, Ceiling_Violation);
  347.    end Read_Lock;
  348.  
  349.    ------------
  350.    -- Unlock --
  351.    ------------
  352.  
  353.    procedure Unlock (L : in out Lock) is
  354.       Result : Interfaces.C.POSIX_Error.Return_Code;
  355.  
  356.    begin
  357.       pthread_mutex_unlock (pthread_mutex_t (L), Result);
  358.       Assert (Result /= Failure, "GNULLI failure---pthread_mutex_unlock");
  359.    end Unlock;
  360.  
  361.    ---------------------
  362.    -- Initialize_Cond --
  363.    ---------------------
  364.  
  365.    procedure Initialize_Cond (Cond : in out Condition_Variable) is
  366.       Attributes : pthread_condattr_t;
  367.       Result     : Interfaces.C.POSIX_Error.Return_Code;
  368.  
  369.    begin
  370.       pthread_condattr_init (Attributes, Result);
  371.  
  372.       if Result = Failure then
  373.          raise STORAGE_ERROR;  --  should be ENOMEM ???
  374.       end if;
  375.  
  376.       pthread_cond_init (pthread_cond_t (Cond), Attributes, Result);
  377.  
  378.       if Result = Failure then
  379.          raise STORAGE_ERROR;  --  should be ENOMEM  ???
  380.       end if;
  381.  
  382.       pthread_condattr_destroy (Attributes, Result);
  383.       Assert (Result /= Failure, "GNULLI failure---pthread_condattr_destroy");
  384.    end Initialize_Cond;
  385.  
  386.    -------------------
  387.    -- Finalize_Cond --
  388.    -------------------
  389.  
  390.    procedure Finalize_Cond (Cond : in out Condition_Variable) is
  391.       Result : Interfaces.C.POSIX_Error.Return_Code;
  392.  
  393.    begin
  394.       pthread_cond_destroy (pthread_cond_t (Cond), Result);
  395.       Assert (Result /= Failure, "GNULLI failure---pthread_cond_destroy");
  396.    end Finalize_Cond;
  397.  
  398.    ---------------
  399.    -- Cond_Wait --
  400.    ---------------
  401.  
  402.    procedure Cond_Wait
  403.      (Cond : in out Condition_Variable;
  404.       L    : in out Lock)
  405.    is
  406.       Result : Interfaces.C.POSIX_Error.Return_Code;
  407.  
  408.    begin
  409.       pthread_cond_wait (pthread_cond_t (Cond), pthread_mutex_t (L), Result);
  410.  
  411.       --  EINTR is not considered a failure.  We have been assured that
  412.       --  Pthreads will soon guarantee that a thread will wake up from
  413.       --  a condition variable wait after it handles a signal.  EINTR will
  414.       --  probably go away at that point. ???
  415.  
  416.       Assert (Result /= Failure or else
  417.         Interfaces.C.POSIX_Error.Get_Error_Code =
  418.            Interfaces.C.POSIX_Error.Interrupted_Operation,
  419.         "GNULLI failure---pthread_cond_wait");
  420.  
  421.    end Cond_Wait;
  422.  
  423.    ---------------------
  424.    -- Cond_Timed_Wait --
  425.    ---------------------
  426.  
  427.    procedure Cond_Timed_Wait
  428.      (Cond      : in out Condition_Variable;
  429.       L         : in out Lock; Abs_Time : Task_Clock.Stimespec;
  430.       Timed_Out : out Boolean)
  431.    is
  432.       Result   : Interfaces.C.POSIX_Error.Return_Code;
  433.       I_Result : Integer;
  434.  
  435.       function Stimespec_to_timespec (S : Task_Clock.Stimespec)
  436.         return Interfaces.C.POSIX_timers.timespec;
  437.  
  438.       function Stimespec_to_timespec (S : Task_Clock.Stimespec)
  439.         return Interfaces.C.POSIX_timers.timespec is
  440.       begin
  441.          return Interfaces.C.POSIX_timers.timespec'
  442.            (tv_sec =>
  443.                Interfaces.C.POSIX_timers.time_t
  444.                   (Task_Clock.Stimespec_Seconds (S)),
  445.             tv_nsec =>
  446.               Interfaces.C.POSIX_timers.Nanoseconds
  447.                  (Task_Clock.Stimespec_NSeconds (S)));
  448.       end Stimespec_to_timespec;
  449.  
  450.    begin
  451.       pthread_cond_timedwait (
  452.         pthread_cond_t (Cond),
  453.         pthread_mutex_t (L),
  454.         Stimespec_to_timespec (Abs_Time),
  455.         Result);
  456.  
  457.       Timed_Out := Result = Failure and then
  458.         Interfaces.C.POSIX_Error.Get_Error_Code =
  459.           Interfaces.C.POSIX_Error.Resource_Temporarily_Unavailable;
  460.       Assert (Result /= Failure or else
  461.             Interfaces.C.POSIX_Error.Get_Error_Code =
  462.               Interfaces.C.POSIX_Error.Resource_Temporarily_Unavailable,
  463.             "GNULLI failure---pthread_cond_timedwait");
  464.    end Cond_Timed_Wait;
  465.  
  466.    -----------------
  467.    -- Cond_Signal --
  468.    -----------------
  469.  
  470.    procedure Cond_Signal (Cond : in out Condition_Variable) is
  471.       Result : Interfaces.C.POSIX_Error.Return_Code;
  472.  
  473.    begin
  474.       pthread_cond_signal (pthread_cond_t (Cond), Result);
  475.       Assert (Result /= Failure, "GNULLI failure---pthread_cond_signal");
  476.    end Cond_Signal;
  477.  
  478.    --------------------
  479.    -- Cond_Broadcast --
  480.    --------------------
  481.  
  482.    procedure Cond_Broadcast (Cond : in out Condition_Variable) is
  483.       Result : Interfaces.C.POSIX_Error.Return_Code;
  484.  
  485.    begin
  486.       pthread_cond_broadcast (pthread_cond_t (Cond), Result);
  487.       Assert (Result /= Failure, "GNULLI failure---pthread_cond_signal");
  488.    end Cond_Broadcast;
  489.  
  490.    ------------------
  491.    -- Set_Priority --
  492.    ------------------
  493.  
  494.    procedure Set_Priority (T : TCB_Ptr; Prio : System.Priority) is
  495.       Attributes : pthread_attr_t;
  496.       Result     : Interfaces.C.POSIX_Error.Return_Code;
  497.  
  498.    begin
  499.       pthread_attr_init (Attributes, Result);
  500.       Assert (Result /= Failure, "GNULLI failure---pthread_attr_init");
  501.  
  502.       pthread_getschedattr (T.Thread, Attributes, Result);
  503.       Assert (Result /= Failure, "GNULLI failure---pthread_getschedattr");
  504.  
  505.       pthread_attr_setprio (Attributes, Priority_Type (Prio), Result);
  506.       Assert (Result /= Failure, "GNULLI failure---pthread_attr_setprio");
  507.  
  508.       pthread_setschedattr (T.Thread, Attributes, Result);
  509.       Assert (Result /= Failure, "GNULLI failure---pthread_setschedattr");
  510.  
  511.       pthread_attr_destroy (Attributes, Result);
  512.       Assert (Result /= Failure, "GNULLI failure---pthread_attr_destroy");
  513.    end Set_Priority;
  514.  
  515.    ----------------------
  516.    -- Set_Own_Priority --
  517.    ----------------------
  518.  
  519.    procedure Set_Own_Priority (Prio : System.Priority) is
  520.       Attributes : pthread_attr_t;
  521.       Result     : Interfaces.C.POSIX_Error.Return_Code;
  522.    begin
  523.       Set_Priority (Self, Prio);
  524.    end Set_Own_Priority;
  525.  
  526.    ------------------
  527.    -- Get_Priority --
  528.    ------------------
  529.  
  530.    function Get_Priority (T : TCB_Ptr) return System.Priority is
  531.       Attributes : pthread_attr_t;
  532.       Prio       : Priority_Type;
  533.       Result     : Interfaces.C.POSIX_Error.Return_Code;
  534.  
  535.    begin
  536.       pthread_attr_init (Attributes, Result);
  537.       Assert (Result /= Failure, "GNULLI failure---pthread_attr_init");
  538.  
  539.       pthread_getschedattr (T.Thread, Attributes, Result);
  540.       Assert (Result /= Failure, "GNULLI failure---pthread_getschedattr");
  541.  
  542.       pthread_attr_getprio (Attributes, Prio, Result);
  543.       Assert (Result /= Failure, "GNULLI failure---pthread_getprio");
  544.  
  545.       pthread_attr_destroy (Attributes, Result);
  546.       Assert (Result /= Failure, "GNULLI failure---pthread_attr_destroy");
  547.  
  548.       return System.Priority (Prio);
  549.    end Get_Priority;
  550.  
  551.    -----------------------
  552.    --  Get_Own_Priority --
  553.    -----------------------
  554.  
  555.    --  Note: this is specialized (rather than being done using a default
  556.    --  parameter for Get_Priority) in case there is a specially efficient
  557.    --  way of getting your own priority, which might well be the case in
  558.    --  general (although is not the case in Pthreads).
  559.  
  560.    function Get_Own_Priority return System.Priority is
  561.    begin
  562.       return Get_Priority (Self);
  563.    end Get_Own_Priority;
  564.  
  565.    ----------------
  566.    -- LL_Wrapper --
  567.    ----------------
  568.  
  569.    procedure LL_Wrapper (T : TCB_Ptr) is
  570.       Result : Interfaces.C.POSIX_Error.Return_Code;
  571.       Old_Set    : RTE.Signal_Set;
  572.  
  573.    begin
  574.       pthread_setspecific (ATCB_Key, Pointer_to_Address (T), Result);
  575.       Assert (Result /= Failure, "GNULLI failure---pthread_setspecific");
  576.  
  577.       RTE.sigprocmask (RTE.SIG_UNBLOCK, LL_Signals, Old_Set, Result);
  578.       Assert (Result /= Failure, "GNULLI failure---sigprocmask");
  579.  
  580.       --  Note that the following call may not return!
  581.  
  582.       T.LL_Entry_Point (T.LL_Arg);
  583.    end LL_Wrapper;
  584.  
  585.    --------------------
  586.    -- Create_LL_Task --
  587.    --------------------
  588.  
  589.    procedure Create_LL_Task
  590.      (Priority       : System.Priority;
  591.       Stack_Size     :  Task_Storage_Size;
  592.       LL_Entry_Point : LL_Task_Procedure_Access;
  593.       Arg            : System.Address;
  594.       T              : TCB_Ptr)
  595.    is
  596.       Attributes : pthread_attr_t;
  597.       Result     : Interfaces.C.POSIX_Error.Return_Code;
  598.       Old_Set    : RTE.Signal_Set;
  599.  
  600.    begin
  601.       T.LL_Entry_Point := LL_Entry_Point;
  602.       T.LL_Arg := Arg;
  603.       T.Stack_Size := Stack_Size;
  604.  
  605.       pthread_attr_init (Attributes, Result);
  606.       Assert (Result /= Failure, "GNULLI failure---pthread_attr_init");
  607.  
  608.       Pthreads.pthread_attr_setdetachstate (Attributes, 1, Result);
  609.       Assert (Result /= Failure, "GNULLI failure---pthread_setdetachstate");
  610.  
  611.       pthread_attr_setstacksize
  612.          (Attributes, Interfaces.C.size_t (Stack_Size), Result);
  613.       Assert (Result /= Failure, "GNULLI failure---pthread_setstacksize");
  614.  
  615.       pthread_attr_setprio (Attributes, Priority_Type (Priority), Result);
  616.       Assert (Result /= Failure, "GNULLI failure---pthread_attr_setprio");
  617.  
  618.       --  It is not safe for the task to be created to accept signals until it
  619.       --  has bound its TCB pointer to the thread with pthread_setspecific ().
  620.       --  The handler wrappers use the TCB pointers to restore the stack limit.
  621.  
  622.       RTE.sigprocmask (RTE.SIG_BLOCK, LL_Signals, Old_Set, Result);
  623.       Assert (Result /= Failure, "GNULLI failure---sigprocmask");
  624.  
  625.       pthread_create (
  626.         T.Thread,
  627.         Attributes,
  628.         LL_Wrapper'Address,
  629.         Pointer_to_Address (T),
  630.         Result);
  631.       Assert (Result /= Failure, "GNULLI failure---pthread_create");
  632.  
  633.       pthread_attr_destroy (Attributes, Result);
  634.       Assert (Result /= Failure, "GNULLI failure---pthread_attr_destroy");
  635.  
  636.       RTE.sigprocmask (RTE.SIG_UNBLOCK, LL_Signals, Old_Set, Result);
  637.       Assert (Result /= Failure, "GNULLI failure---sigprocmask");
  638.  
  639.    end Create_LL_Task;
  640.  
  641.    ------------------
  642.    -- Exit_LL_Task --
  643.    ------------------
  644.  
  645.    procedure Exit_LL_Task is
  646.    begin
  647.       pthread_exit (System.Null_Address);
  648.    end Exit_LL_Task;
  649.  
  650.    ----------------
  651.    -- Abort_Task --
  652.    ----------------
  653.  
  654.    procedure Abort_Task (T : TCB_Ptr) is
  655.       Result : Interfaces.C.POSIX_Error.Return_Code;
  656.  
  657.    begin
  658.       pthread_kill (T.Thread, Abort_Signal, Result);
  659.       Assert (Result /= Failure, "GNULLI failure---pthread_kill");
  660.    end Abort_Task;
  661.  
  662.    ----------------
  663.    -- Test_Abort --
  664.    ----------------
  665.  
  666.    --  This procedure does nothing.  It is intended for systems without
  667.    --  asynchronous abortion, where the runtime system would have to
  668.    --  synchronously poll for pending abortions.  This should be done
  669.    --  at least at every synchronization point.
  670.  
  671.    procedure Test_Abort is
  672.    begin
  673.       null;
  674.    end Test_Abort;
  675.  
  676.    ---------------------
  677.    -- Get_Stack_Limit --
  678.    ---------------------
  679.  
  680.    function Get_Stack_Limit return System.Address is
  681.    begin
  682.       return Self.Stack_Limit;
  683.    end Get_Stack_Limit;
  684.  
  685.    -------------------
  686.    -- Abort_Wrapper --
  687.    -------------------
  688.  
  689.    --  Note that this currently takes System.Address.  The 1 specifies
  690.    --  access procedure (Context : Pre_Call_State) for the handler type.
  691.    --  This may be a mistake of the interface in commiting to this 9X type.
  692.    --  The right way to do it may be to make this a type in Machine_Specifics,
  693.    --  which can then be created with a constructor funciton in one place.
  694.    --  However, Ada 83 compilers are always going to have to take the address
  695.    --  of the procedure, if only to pass it to a constructor function. ???
  696.  
  697.    --  Isn't above comment obsolete. Certainly the reference to package
  698.    --  Machine_Specifics is obsolete ???
  699.  
  700.    procedure Abort_Wrapper
  701.      (signo   : Integer;
  702.       info    : RTE.siginfo_ptr;
  703.       context : System.Address)
  704.    is
  705.       function Address_To_Call_State is new
  706.         Unchecked_Conversion (System.Address, Pre_Call_State);
  707.  
  708.    begin
  709.       Abort_Handler (Address_To_Call_State (context));
  710.    end Abort_Wrapper;
  711.  
  712.    ---------------------------
  713.    -- Install_Abort_Handler --
  714.    ---------------------------
  715.  
  716.    procedure Install_Abort_Handler (Handler : Abort_Handler_Pointer) is
  717.       act     : RTE.struct_sigaction;
  718.       old_act : RTE.struct_sigaction;
  719.       Result  : Interfaces.C.POSIX_Error.Return_Code;
  720.  
  721.    begin
  722.       Abort_Handler := Handler;
  723.       act.sa_handler := Abort_Wrapper'Address;
  724.       RTE.Signal_Delete_All (act.sa_mask);
  725.       act.sa_flags := 0;
  726.  
  727.       RTE.sigaction (Abort_Signal, act, old_act, Result);
  728.       Assert (Result /= Failure, "GNULLI failure---sigaction");
  729.    end Install_Abort_Handler;
  730.  
  731.    ---------------------------
  732.    -- Install_Error_Handler --
  733.    ---------------------------
  734.  
  735.    procedure Install_Error_Handler (Handler : System.Address) is
  736.       act     : RTE.struct_sigaction;
  737.       old_act : RTE.struct_sigaction;
  738.       Result  : Interfaces.C.POSIX_Error.Return_Code;
  739.  
  740.    begin
  741.       act.sa_handler := Handler;
  742.  
  743.       RTE.Signal_Delete_All (act.sa_mask);
  744.       RTE.Signal_Add (act.sa_mask, RTE.SIGILL);
  745.       RTE.Signal_Add (act.sa_mask, RTE.SIGABRT);
  746.       RTE.Signal_Add (act.sa_mask, RTE.SIGFPE);
  747.       RTE.Signal_Add (act.sa_mask, RTE.SIGSEGV);
  748.       act.sa_flags := 0;
  749.  
  750.       RTE.sigaction (RTE.SIGILL, act, old_act, Result);
  751.       Assert (Result /= Failure, "GNULLI failure---sigaction");
  752.  
  753.       RTE.sigaction (RTE.SIGABRT, act, old_act, Result);
  754.       Assert (Result /= Failure, "GNULLI failure---sigaction");
  755.  
  756.       RTE.sigaction (RTE.SIGFPE, act, old_act, Result);
  757.       Assert (Result /= Failure, "GNULLI failure---sigaction");
  758.  
  759.       RTE.sigaction (RTE.SIGSEGV, act, old_act, Result);
  760.       Assert (Result /= Failure, "GNULLI failure---sigaction");
  761.  
  762.    end Install_Error_Handler;
  763.  
  764.    ------------------
  765.    -- Test_And_Set --
  766.    ------------------
  767.  
  768.    procedure Test_And_Set (Flag_Add : System.Address; Result : out Boolean) is
  769.       type Access_Boolean is access Boolean;
  770.       Error : Boolean;
  771.  
  772.       function Address_To_Pointer is new
  773.         Unchecked_Conversion (System.Address, Access_Boolean);
  774.  
  775.    begin
  776.       Write_Lock (Test_And_Set_Mutex, Error);
  777.  
  778.       if not Address_To_Pointer (Flag_Add).all then
  779.          Address_To_Pointer (Flag_Add).all := True;
  780.          Unlock (Test_And_Set_Mutex);
  781.          Result :=  True;
  782.       else
  783.          Unlock (Test_And_Set_Mutex);
  784.          Result := False;
  785.       end if;
  786.    end Test_And_Set;
  787.  
  788. begin
  789.    Initialize_Lock (System.Priority'Last, Test_And_Set_Mutex);
  790. end System.Task_Primitives;
  791.